home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / comp-utl.em < prev    next >
Lisp/Scheme  |  1993-07-03  |  5KB  |  197 lines
  1. ;; Eulisp Module
  2. ;; Author: pete broadbery
  3. ;; File: comp-utils.em
  4. ;; Date: 1/sep/1991
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;   sundry compiler utliities...
  9. ;;
  10.  
  11. (defmodule comp-utl
  12.   (standard0
  13.    list-fns
  14.    module-operators
  15.    )
  16.   ()
  17.   
  18.   (defclass read-error (<condition>)
  19.     ()
  20.     metaclass <condition-class>)
  21.   (defclass cannot-open-path (<condition>)
  22.     ()
  23.     metaclass <condition-class>)
  24.     
  25.   (defun make-search-path (shell-var separator default)
  26.     (let ((sp (or (getenv shell-var) default))
  27.       (sp-length 0))
  28.       (if (null sp)
  29.       (list ".")
  30.     (labels (
  31.          (dissect-path (index previous-index index-pairs)
  32.             (if (= index sp-length)
  33.             (cons (cons previous-index (- index 1)) index-pairs)
  34.               (if (equal (string-ref sp index) separator)
  35.               (dissect-path
  36.                (+ index 1)
  37.                (+ index 1)
  38.                (cons (cons previous-index (- index 1)) index-pairs))
  39.             (dissect-path (+ index 1) previous-index index-pairs)))))
  40.         (setq sp-length (string-length sp))
  41.         (reverse
  42.          (mapcar (lambda (start-finish)
  43.                (substring sp (car start-finish) (cdr start-finish)))
  44.              (dissect-path 0 0 ())))))))
  45.  
  46.   (defun path-open (pathlist name . options)
  47.     (let/cc succeed
  48.         (mapc (lambda (path)
  49.             (let/cc fail
  50.                 (with-handler (lambda (a b) (fail ()))
  51.                       (succeed (apply open (format nil "~a/~a" path name) options)))))
  52.           pathlist)
  53.         (error
  54.          (format nil "path-open: cannot open stream for (~a) ~a" pathlist name)
  55.          cannot-open-path)
  56.         nil))
  57.  
  58.   (export make-search-path path-open)
  59.   
  60.   ;; macro expansion. 
  61.   ;; low-level
  62.   
  63.   (defun get-expander (module-name name)
  64.     (let ((module (get-module module-name)))
  65.       (dynamic-access module name)))
  66.  
  67.   (defun interface-file-name (x) (format nil "~a.i" x))
  68.  
  69.   (defun get-module-stream (x) 
  70.     (open (format nil "~a.em" x)))
  71.   
  72.   (defun fast-file-name (x)
  73.     (format nil "~a.fm" x))
  74.  
  75.   (export get-expander interface-file-name get-module-stream fast-file-name)
  76.  
  77.   ;; bytecode file-names
  78.  
  79.   (defun bytecode-file-name (x) 
  80.     (format nil "~a.bc" x))
  81.  
  82.   (defun encapsulated-byte-file-name (x)
  83.      (format nil "~a.ebc" x))
  84.  
  85.   (defun encapsulated-static-file-name (x)
  86.      (format nil "~a.est" x))
  87.  
  88.   (defun sc-file-name (x)
  89.      (format nil "~a.sc" x))
  90.  
  91.   (export bytecode-file-name encapsulated-byte-file-name
  92.       encapsulated-static-file-name
  93.       sc-file-name)
  94.  
  95.   ;; Reading and writing files. 
  96.   ;; both cute hacks.
  97.  
  98.   (defun write-object (x file-name . path)
  99.     (let ((xx (path-open (if path (car path) '("./")) file-name 'output  t)))
  100.       (unwind-protect
  101.       (safe-write (fold (lambda (slot lst)
  102.                   (cons (car (slot-description-initargs slot))
  103.                     (cons (slot-value x (slot-description-name slot))
  104.                       lst)))
  105.                 (class-slot-descriptions (class-of x))
  106.                 nil)
  107.               xx)
  108.     (close xx)
  109.     )))
  110.     
  111.   (defun read-object (class file-name . path)
  112.     (let ((file (path-open  (if path (car path) '("./")) file-name)))
  113.       (unwind-protect (apply make-instance class 
  114.                  (safe-read file))
  115.     (close file))))
  116.   
  117.   (export read-object write-object)
  118.   
  119.   (defgeneric safe-write (object stream))
  120.  
  121.   (defmethod safe-write (object stream)
  122.     (write object stream))
  123.   
  124.   (defun safe-read (stream)
  125.     (read stream))
  126.  
  127.     
  128.   ;; end module
  129.   )
  130. (defun safe-read (stream)
  131.     (labels ((get-list (stream last-pair)
  132.                (let ((next (safe-read stream)))
  133.              (cond ((eq next list-end-symbol)
  134.                 nil)
  135.                    ((eq next list-improper-symbol)
  136.                 (let* ((next-1 (safe-read stream))
  137.                        (next-2 (safe-read stream)))
  138.                   (if (not (eq next-2 list-end-symbol))
  139.                       (error "Misplaced dot causing error" read-error)
  140.                     ((setter cdr) last-pair next-1))))
  141.                    (t (let ((new-last (cons next nil)))
  142.                     ((setter cdr) last-pair new-last)
  143.                     (get-list stream new-last))))))
  144.          (start-list (stream)
  145.              (let ((next (read stream)))
  146.                (cond ((eq next list-start-symbol)
  147.                   (let ((first-pair (cons (start-list stream) nil)))
  148.                     (get-list stream first-pair)
  149.                     first-pair))
  150.                  ((eq next list-end-symbol)
  151.                   (let ((first-pair (cons nil nil)))
  152.                     (get-list stream first-pair)
  153.                     first-pair))
  154.                  ((eq next list-improper-symbol)
  155.                   (error "improper list" read-error))
  156.                  (t (let ((first-pair (cons next nil)))
  157.                       (get-list stream first-pair)
  158.                       first-pair))))))
  159.         (let ((obj (read stream)))
  160.           (if (not (eq obj list-start-symbol))
  161.           obj
  162.         (start-list stream)))))
  163.  
  164.   (defun list-too-long-p (x) t) 
  165.  
  166.   (defun space (stream) 
  167.     (prin " " stream))
  168.  
  169.   (defmethod safe-write ((lst <pair>) stream)
  170.     (labels ((do-safe-write (lst stream)
  171.                 (cond ((null lst)
  172.                    (write list-end-symbol stream)
  173.                    (space stream))
  174.                   ((atom lst)
  175.                    (write list-improper-symbol stream)
  176.                    (space stream)
  177.                    (safe-write lst stream)
  178.                    (space stream)
  179.                    (write list-end-symbol stream)
  180.                    (space stream))
  181.                   (t
  182.                    (safe-write (car lst) stream)
  183.                    (space stream)
  184.                    (do-safe-write (cdr lst) stream)))))
  185.         (if (list-too-long-p lst)
  186.         (progn (write list-start-symbol stream)
  187.                (space stream)
  188.                (do-safe-write lst stream))
  189.           (write stream lst))))
  190.  
  191.   ;; read hacks for big lists
  192.   ;; Note: we cannot say 'foo for obvious reasons
  193.   (defconstant list-start-symbol (make-symbol "%_List_start_%"))
  194.   (defconstant list-end-symbol (make-symbol "%_List_end_%"))
  195.   (defconstant list-improper-symbol (make-symbol "%_dotty_thing_%"))
  196.  
  197.